home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Yerk 3.6.7 / yerk 367 / nuc / yerk3.67.txt < prev   
Text File  |  1994-09-21  |  80KB  |  1,717 lines
  1. ; System 7 modifications
  2. ; courier 9pt -9 spacing tabs: .875 1.5 3.625
  3. ; need to change modification in vers RSRC
  4. ; flush caches in trap; fix d0 saves for flushes
  5. ; fixed s,; added ucase in word_
  6. ; 6/1/94 changed at1,2,4 to not use (sp)+,-
  7. ; 3.66=3.64
  8. ;    Load equates for Toolbox, Quickdraw
  9.     LIST OFF
  10.     INCLUDE    "library.asm"
  11.     INCLUDE    "equates.asm"
  12.     INCLUDE    "yerk.macro"
  13. *
  14. gestalt    EQU    $a1ad
  15. newhandc    EQU    $a322
  16. newPtrc    EQU    $a31e
  17. stripAddress    EQU    $a055
  18. waitNextEvt    EQU    $a860
  19. HWPriv    EQU    $a198
  20.     GLOBAL    $200,$200
  21.     ENDG
  22.     TFILE "YERK.BIN"
  23.     RFILE "YERK",APPL,YERK,$2100    ; has bundle,init
  24. ;
  25. Rsize    EQU    400    ; Maximum depth of ret+mstack
  26. Rbytes    EQU    -Rsize*4    ; Number of bytes for ret+mstack
  27. MSbytes    EQU    1200    ; 300 cells on methods stack
  28. sysVects    EQU    17    ; how many system vectors + 1 (for len)
  29. sysVecSz    EQU    sysVects*4    ; total len of system vector table
  30. ; 'SAVE' HEADER EQUATES.
  31. udp    EQU    0    ; User dictionary pointer
  32. ufence    EQU    4    ; User fence pointer
  33. uvocl    EQU    8    ; User vocabulary pointer
  34. ulatest    EQU    12    ; Latest NFA.
  35. headlen    EQU    16    ; Lengt
  36.     mulu    d0,d2
  37.     add.l    d2,(SP)
  38.     move.l    (a6)+,-(SP)
  39.     rts
  40. smpy    move.l    (SP)+,-(a6)
  41.     tst.l    (SP)    ; signed multiply
  42.     smi    d4
  43.     bpl    smpy1
  44.     neg.l    (SP)
  45. smpy1    tst.l    4(SP)
  46.     smi    d3
  47.     bpl    smpy2
  48.     neg.l    4(SP)
  49. smpy2    eor.b    d3,d4
  50.     bsr.s    mpy
  51.     tst.b    d4
  52.     beq    smpy3
  53.     neg.l    4(SP)
  54.     negx.l    (SP)
  55. smpy3    move.l    (a6)+,-(SP)
  56.     rts
  57. xdiv    move.l    (SP)+,-(a6)
  58.     tst.l    (SP)
  59.     beq    div5
  60.     tst.w    (SP)
  61.     bne    longdiv
  62.     tst.l    4(SP)
  63.     bne    longdiv
  64.     move.l    (SP)+,d2
  65.     popd0
  66.     popd1
  67.     divu    d2,d1
  68.     bvs    long1
  69.     clr.l    d2
  70.     move.w    d1,d2
  71.     clr.w    d1
  72.     swap    d1
  73.     pushd1
  74.     move.l    d2,-(SP)
  75.     move.l    (a6)+,-(SP)
  76.     rts
  77. longdiv    move.l    (SP)+,d2    ; the dreaded long division
  78.     popd0
  79.     popd1
  80. long1    moveq    #32,d3
  81.     sub.l    d2,d0
  82. div1    bmi    div2
  83.     ori.l    #1,d1
  84.     subq.w    #1,d3
  85.     bmi    div3
  86.     asl.l    #1,d1
  87.     roxl.l    #1,d0
  88.     sub.l    d2,d0
  89.     bra.s    div1
  90.     
  91. div2    subq.w    #1,d3
  92.     bmi    div3
  93.     asl.l    #1,d1
  94.     roxl.l    #1,d0
  95.     add.l    d2,d0
  96.     bra.s    div1
  97. div3    tst.l    d0
  98.     bpl    div4
  99.     add.l    d2,d0
  100. div4    pushd0
  101.     pushd1
  102.     move.l    (a6)+,-(SP)
  103.     rts
  104. div5    addq.l    #4,SP
  105.     move.l    d2,4(SP)
  106.     move.l    #$7fffffff,(SP)
  107.     move.l    (a6)+,-(SP)
  108.     rts
  109. sdiv    move.l    (SP)+,-(a6)    ; save return address from jsr
  110.     tst.l    (SP)    ; signed divide
  111.     smi    d7    ; d4 change to d7  8-24-91
  112.     bpl    sdiv1
  113.     neg.l    (SP)
  114. sdiv1    tst.l    4(SP)
  115.     smi    d4    ; d7 changed to d4 to let rem sign = quotient sign
  116.     bpl    sdiv2
  117.     neg.l    8(SP)
  118.     negx.l    4(SP)
  119. sdiv2    eor.b    d4,d7
  120.     bsr    xdiv
  121.     tst.b    d7
  122.     beq    sdiv3
  123.     neg.l    (SP)
  124. sdiv3    tst.b    d4
  125.     beq    sdiv4
  126.     neg.l    4(SP)
  127. sdiv4    move.l    (a6)+,-(SP)
  128.     rts
  129. slmod    move.l    (SP)+,-(a6)
  130.     moveq    #0,d1
  131.     popd0
  132.     tst.l    (SP)
  133.     bpl    slmod1
  134.     subq.l    #1,d1
  135. slmod1    pushd1
  136.     pushd0
  137.     move.l    (a6)+,-(SP)
  138.     bra.s    sdiv
  139. *
  140.     dcode    U*,x,cmove,ustar
  141.     bsr    mpy
  142.     gonext
  143. *
  144.     dcode    U/,x,ustar,uslash
  145.     bsr    xdiv
  146.     gonext
  147. *
  148.     dcode    M*,x,uslash,mstar
  149.     bsr    smpy
  150.     gonext
  151. *
  152.     dcode    M/,x,mstar,mslash
  153.     bsr    sdiv
  154.     gonext
  155. *
  156.     dcode    */,x,mslash,starsla
  157.     move.l    (SP)+,-(a6)
  158.     bsr    smpy
  159.     move.l    (a6)+,-(SP)
  160.     bsr    sdiv
  161.     move.l    (SP)+,(SP)
  162.     gonext
  163. *
  164.     dcode    */MOD,x,starsla,ssmod
  165.     move.l    (SP)+,-(a6)
  166.     bsr    smpy
  167.     move.l    (a6)+,-(SP)
  168.     bsr    sdiv
  169.     gonext
  170. *
  171.     dcode    M/MOD,x,ssmod,msmod
  172.     move.l    (SP)+,-(a6)
  173.     moveq    #0,d0
  174.     pushd0
  175.     move.l    (a6),-(SP)
  176.     bsr    xdiv
  177.     move.l    (a6)+,d0
  178.     move.l    (SP)+,-(a6)
  179.     pushd0
  180.     bsr    xdiv
  181.     move.l    (a6)+,-(SP)
  182.     gonext
  183. *
  184.     dcode    *,x,msmod,star    ; *
  185.     bsr    smpy
  186.     addq.l    #4,SP    ; drop top of stack
  187.     gonext
  188. *
  189.     dcode    /,x,star,slash    ; /
  190.     bsr    slmod
  191.     move.l    (SP)+,(SP)
  192.     gonext
  193. *
  194.     dcode    /MOD,x,slash,xslmod    ; /MOD
  195.     bsr    slmod
  196.     gonext
  197. *
  198.     dcode    MOD,x,xslmod,mod    ; MOD
  199.     bsr    slmod
  200.     addq.l    #4,SP
  201.     gonext
  202. *
  203.     dcode    D>,x,mod,dgrt    ; D>
  204.     moveq    #1,d0
  205.     move.l    8(SP),d1
  206.     cmp.l    (SP),d1
  207.     bgt    dgrt1
  208.     move.l    12(SP),d1
  209.     cmp.l    4(SP),d1
  210.     bgt    dgrt1
  211.     moveq    #0,d0
  212. dgrt1    adda.l    #16,SP
  213.     pushd0
  214.     gonext
  215. *
  216.     dcode    D<,x,dgrt,dless    ; D<
  217.     moveq    #1,d0
  218.     move.l    8(SP),d1
  219.     cmp.l    (SP),d1
  220.     blt    dless1
  221.     move.l    12(SP),d1
  222.     cmp.l    4(SP),d1
  223.     blt    dless1
  224.     moveq    #0,d0
  225. dless1    adda.l    #16,SP
  226.     pushd0
  227.     gonext
  228. *
  229.     dcode    D=,x,dless,dequ    ; D=
  230.     move.l    (SP),d1
  231.     cmp.l    8(SP),d1
  232.     seq    d0
  233.     move.l    4(SP),d1
  234.     cmp.l    12(SP),d1
  235.     seq    d1
  236.     adda.l    #16,SP
  237.     and.l    d1,d0
  238.     bra    setbyt
  239.     gonext
  240. *
  241.     dcode    U<,x,dequ,uless
  242.     cmp2
  243.     scs    d0
  244.     bra.s    setbyt
  245. *
  246.     dcode    U>,x,uless,ugrt
  247.     cmp2
  248.     scc    d0
  249.     bra.s    setbyt
  250. *
  251.     dcode    <,x,ugrt,less    ; <
  252.     cmp2
  253.     slt    d0
  254.     bra.s    setbyt
  255. *
  256.     dcode    >,x,less,grt    ; >
  257.     cmp2
  258.     sgt    d0
  259.     bra.s    setbyt
  260. *
  261.     dcode    =,x,grt,equals    ; =
  262.     cmp2
  263.     seq    d0
  264.     bra.s    setbyt
  265. *
  266.     dcode    <>,x,equals,nequals
  267.     cmp2
  268.     sne    d0
  269.     bra.s    setbyt
  270. *
  271.     dcode    0=,x,nequals,zequ
  272.     tst.l    (SP)+
  273.     seq    d0
  274.     bra.s    setbyt
  275. *
  276.     dcode    0<,x,zequ,zless
  277.     tst.l    (SP)+
  278.     smi    d0
  279. setbyt    moveq    #1,d1
  280.     and.l    d1,d0
  281.     pushD0
  282.     gonext
  283. *
  284.     dcode    0>,x,zless,zgrt
  285.     tst.l    (SP)+
  286.     sgt    d0
  287.     bra.s    setbyt
  288. *
  289.     dcode    <=,x,zgrt,lesequ
  290.     cmp2
  291.     sle    d0
  292.     bra.s    setbyt
  293. *
  294.     dcode    >=,x,lesequ,grtequ
  295.     cmp2
  296.     sge    d0
  297.     bra.s    setbyt
  298. *
  299.     dcode    0!,x,grtequ,zstore    ; store 0 at addr
  300.     move.l    (sp)+,d7
  301.     clr.l    0(a3,d7.l)
  302.     gonext
  303. *
  304.     dcode    0,x,zstore,pzer    ; short, fast 0 word
  305.     clr.l    -(SP)
  306.     gonext
  307. *
  308.     dcode    1,x,pzer,pone    ; short, fast 1 word
  309.     move.l    #1,-(SP)
  310.     gonext
  311. *
  312.     dcode    -1,x,pone,pmone    ; short, fast -1 word
  313.     move.l    #-1,-(SP)
  314.     gonext
  315. *
  316.     dcode    2,x,pmone,ptwo    ; short, fast 2 word
  317.     move.l    #2,-(SP)
  318.     gonext
  319. *
  320.     dcode    4,x,ptwo,pfour
  321.     move.l    #4,-(SP)
  322.     gonext
  323. *
  324.     dcode    AND,x,pfour,and_
  325.     popD0
  326.     and.l    d0,(SP)
  327.     gonext
  328. *
  329.     dcode    LAND,x,and_,land_
  330.     popd0
  331.     tst.l    (SP)
  332.     beq    land2
  333.     move.l    #1,(SP)
  334.     tst.l    d0
  335.     beq    land1
  336.     mo
  337.     gonext
  338. *
  339.     dcode    MP2,x,mp1,mp2    ; mstack picks for named parms
  340.     move.l    d5,a2
  341.     move.l    16(a2),-(SP)    ; push parm to data stack
  342.     gonext
  343. *
  344.     dcode    MP3,x,mp2,mp3    ; mstack picks for named parms
  345.     move.l    d5,a2
  346.     move.l    20(a2),-(SP)    ; push parm to data stack
  347.     gonext
  348. *
  349.     dcode    MP4,x,mp3,mp4    ; mstack picks for named parms
  350.     move.l    d5,a2
  351.     move.l    24(a2),-(SP)    ; push parm to data stack
  352.     gonext
  353. *
  354.     dcode    MP5,x,mp4,mp5    ; mstack picks for named parms
  355.     move.l    d5,a2
  356.     move.l    28(a2),-(SP)    ; push parm to data stack
  357.     gonext
  358. *
  359.     dcode    MS0,x,mp5,ms0    ; mstack stores for named parms
  360.     move.l    d5,a2
  361.     move.l    (SP)+,8(a2)    ; replace parm val with top of stack
  362.     gonext
  363. *
  364.     dcode    MS1,x,ms0,ms1    ; mstack stores for named parms
  365.     move.l    d5,a2
  366.     move.l    (SP)+,12(a2)    ; replace parm val with top of stack
  367.     gonext
  368. *
  369.     dcode    MS2,x,ms1,ms2    ; mstack stores for named parms
  370.     move.l    d5,a2
  371.     move.l    (SP)+,16(a2)    ; replace parm val with top of stack
  372.     gonext
  373. *
  374.     dcode    MS3,x,ms2,ms3    ; mstack stores for named parms
  375.     move.l    d5,a2
  376.     move.l    (SP)+,20(a2)    ; replace parm val with top of stack
  377.     gonext
  378. *
  379.     dcode    MS4,x,ms3,ms4    ; mstack stores for named parms
  380.     move.l    d5,a2
  381.     move.l    (SP)+,24(a2)    ; replace parm val with top of stack
  382.     gonext
  383. *
  384.     dcode    MS5,x,ms4,ms5    ; mstack stores for named parms
  385.     move.l    d5,a2
  386.     move.l    (SP)+,28(a2)    ; replace parm val with top of stack
  387.     gonext
  388. *
  389.     dcode    (++>),x,ms5,minc    ; increment named parm
  390.     move.l    d5,a2
  391.     move.w    (a4)+,d0    ; get element offset
  392.     move.l    (sp)+,d1    ; get increment value
  393.     add.l    d1,0(a2,d0.w)    ; increment the cell
  394.     gonext
  395. *
  396.     dcode    (EX>),x,minc,mdo    ; execute a procedural arg
  397.     move.l    d5,a2
  398.     move.w    (a4)+,d0    ; get offset to named parm
  399.     move.l    0(a2,d0.w),d6    ; get the cfa
  400.     move.l    0(a3,d6.l),d7    ; get the code
  401.     jmp    0(a3,d7.l)
  402. *
  403.     dcode    +,x,mdo,plus
  404.     popD0
  405.     add.l    d0,(SP)
  406.     gonext
  407. *
  408.     dcode    -,x,plus,subt
  409.     popD0
  410.     sub.l    d0,(SP)
  411.     gonext
  412. *
  413.     dcode    MAX,x,subt,max
  414.     popD0
  415.     cmp.l    (SP),d0
  416.     blt    maxq
  417.     move.l    d0,(SP)
  418. maxq    gonext
  419. *
  420.     dcode    MIN,x,max,min
  421.     popD0
  422.     cmp.l    (SP),d0
  423.     bgt    minq
  424.     move.l    d0,(SP)
  425. minq    gonext
  426. *
  427.     dcode    NEGATE,x,min,minus
  428. mins1    neg.l    (SP)
  429.     gonext
  430. *
  431.     dcode    DNEGATE,x,minus,dminus
  432. dmins1    neg.l    4(SP)
  433.     negx.l    (SP)
  434.     gonext
  435. *
  436.     dcode    CFA,x,dminus,cfa
  437.     subq.l    #4,(SP)
  438.     gonext
  439. *
  440.     dcode    +-,x,cfa,plmin
  441.     tst.l    (SP)+
  442.     bmi.s    mins1
  443.     gonext
  444. *
  445.     dcode    ABS,x,plmin,abs
  446.     tst.l    (SP)
  447.     bmi.s    mins1
  448.     gonext
  449. *
  450.     dcode    DABS,x,abs,dabs
  451.     tst.l    (SP)
  452.     bmi.s    dmins1
  453.     gonext
  454. *
  455.     dcode    S->D,x,dabs,sToD
  456.     moveq    #0,d0
  457.     tst.l    (SP)
  458.     bpl    GOHERE
  459.     subq.l    #1,d0
  460. GOHERE    pushd0
  461.     gonext
  462. *
  463.     dcode    OVER,x,sToD,over
  464.     move.l    4(SP),-(SP)
  465.     gonext
  466. *
  467.     dcode    2OVER,x,over,over2
  468.     move.l    12(SP),-(SP)
  469.     move.l    12(SP),-(SP)
  470.     gonext
  471. *
  472.     dcode    DROP,x,over2,drop
  473.     addq.l    #4,SP
  474.     gonext
  475. *
  476.     dcode    2DROP,x,drop,drop2
  477.     addq.l    #8,SP
  478.     gonext
  479. *
  480.     dcode    SWAP,x,drop2,swap_
  481.     popD0
  482.     move.l    (SP),d1
  483.     move.l    d0,(SP)
  484.     pushD1
  485.     gonext
  486. *
  487.     dcode    2SWAP,x,swap_,swap2
  488.     popD0
  489.     popD1
  490.     move.l    (SP)+,d3
  491.     move.l    (SP),d4
  492.     move.l    d1,(SP)
  493.     move.l    d0,-(SP)
  494.     move.l    d4,-(SP)
  495.     move.l    d3,-(SP)
  496.     gonext
  497. *
  498.     dcode    DUP,x,swap2,dup
  499.     move.l    (SP),-(SP)
  500.     gonext
  501. *
  502.     dcode    2DUP,x,dup,dup2
  503.     move.l    4(SP),-(SP)
  504.     move.l    4(SP),-(SP)
  505.     gonext
  506. *
  507.     dcode    -DUP,x,dup2,mindup
  508.     tst.l    (SP)
  509.     beq    ddup
  510.     move.l    (SP),-(SP)
  511. ddup    gonext
  512. *
  513.     dcode    +!,x,mindup,plstor
  514.     move.l    (SP)+,d7
  515.     popD0
  516.     add.l    d0,0(a3,d7.l)
  517.     gonext
  518. *
  519.     dcode    TOGGLE,x,plstor,toggle
  520.     popD0
  521.     move.l    (SP)+,d7
  522.     eor.b    d0,0(a3,d7.l)
  523.     gonext
  524. *
  525.     dcode    W@,x,toggle,wfetch    ; this is a 16-bit fetch
  526.     clr.l    d0
  527.     move.l    (SP),d7
  528.     move.w    0(a3,d7.l),d0
  529.     move.l    d0,(SP)
  530.     gonext
  531. *
  532.     dcode    @,x,wfetch,fetch    ; this is a 32-bit fetch
  533.     move.l    (SP),d7
  534.     move.l    0(a3,d7.l),(SP)
  535.     gonext
  536. *
  537.     dcode    C@,x,fetch,cfetch
  538.     clr.l    d0
  539.     move.l    (SP),d7
  540.     move.b    0(a3,d7.l),d0
  541.     move.l    d0,(SP)
  542.     gonext
  543. *
  544.     dcode    MW@,x,cfetch,mwfetch    ; 16-bit fetch from mstack addr
  545.     move.l    d5,a2
  546.     clr.l    d0
  547.     move.l    (a2),d7
  548.     move.w    0(a3,d7.l),d0
  549.     ext.l    d0    ; sign-extend
  550.     move.l    d0,-(SP)
  551.     gonext
  552. *
  553.     dcode    M@,x,mwfetch,mfetch    ; this is a 32-bit fetch
  554.     move.l    d5,a2
  555.     move.l    (a2),d7
  556.     move.l    0(a3,d7.l),-(SP)
  557.     gonext
  558. *
  559.     dcode    2@,x,mfetch,fetch2    ; ( double word fetch )
  560.     move.l    (SP),d7
  561.     lea    0(a3,d7.l),a0
  562.     move.l    (a0)+,-(sp)
  563.     move.l    (a0),4(SP)
  564.     gonext
  565. *
  566.     dcode    W!,x,fetch2,wstore    ; 16-bit store
  567.     move.l    (SP)+,d7    ; address is relative to a3
  568.     popD0        ; d0 has value
  569.     move.w    d0,0(a3,d7.l)
  570.     gonext
  571. *
  572.     dcode    W+!,x,wstore,wpstore    ; 16-bit plus store
  573.     move.l    (SP)+,d7
  574.     popD0
  575.     add.w    d0,0(a3,d7.l)
  576.     gonext
  577. *
  578.     dcode    !,x,wpstore,store    ; 32-bit store
  579.     move.l    (SP)+,d7    ; address is relative to a3
  580.     popD0        ; d0 has value
  581.     move.l    d0,0(a3,d7.l)
  582.     gonext
  583. *
  584.     dcode    C!,x,store,cstore
  585.     move.l    (SP)+,d7
  586.     popD0
  587.     move.b    d0,0(a3,d7.l)
  588.     gonext
  589. *
  590.     dcode    C+!,x,cstore,cpstore    ; 8 bit plus store
  591.     move.l    (SP)+,d7
  592.     popD0
  593.     add.b    d0,0(a3,d7.l)
  594.     gonext
  595. *
  596.     dcode    MW!,x,cpstore,mwstore    ; 16-bit store to addr on mstack
  597.     move.l    d5,a2
  598.     move.l    (a2),d7    ; address is relative to a3
  599.     popD0        ; d0 has value
  600.     move.w    d0,0(a3,d7.l)
  601.     gonext
  602. *
  603.     dcode    M!,x,mwstore,mstore    ; 32-bit store to addr on mstack
  604.     move.l    d5,a2
  605.     move.l    (a2),d7    ; address is relative to a3
  606.     popD0        ; d0 has value
  607.     move.l    d0,0(a3,d7.l)
  608.     gonext
  609. *
  610.     dcode    2!,x,mstore,store2    ; ( double word store )
  611.     move.l    (SP)+,d7
  612.     lea    0(a3,d7.l),a0
  613.     move.l    (SP)+,(a0)+
  614.     move.l    (SP)+,(a0)
  615.     gonext
  616. *
  617.     dcode    D+,x,store2,dplus    ; 64-bit add
  618.     popd0
  619.     popd1
  620.     move.l    (SP)+,d2
  621.     move.l    (sp)+,d3
  622.     add.l    d1,d3
  623.     addx.l    d0,d2
  624.     move.l    d3,-(SP)
  625.     move.l    d2,-(SP)
  626.     gonext
  627. *
  628.     dcode    1+,x,dplus,plus1
  629.     addq.l    #1,(SP)
  630.     gonext
  631. *
  632.     dcode    2+,x,plus1,plus2
  633.     addq.l    #2,(SP)
  634.     gonext
  635. *
  636.     dcode    3+,x,plus2,plus3
  637.     addq.l    #3,(SP)
  638.     gonext
  639. *
  640.     dcode    4+,x,plus3,plus4
  641.     addq.l    #4,(SP)
  642.     gonext
  643. *
  644.     dcode    8+,x,plus4,plus8
  645.     addq.l    #8,(SP)
  646.     gonext
  647. *
  648.     dcode    1-,x,plus8,min1
  649.     subq.l    #1,(SP)
  650.     gonext
  651. *
  652.     dcode    2-,x,min1,min2
  653.     subq.l    #2,(SP)
  654.     gonext
  655. *
  656.     dcode    4-,x,min2,min4
  657.     subq.l    #4,(SP)
  658.     gonext
  659. *
  660.     dcode    8-,x,min4,min8
  661.     subq.l    #8,(SP)
  662.     gonext
  663. *
  664.     dcode    2*,x,min8,times2
  665.     move.l    (SP),d0
  666.     asl.l    #1,d0
  667.     move.l    d0,(SP)
  668.     gonext
  669. *
  670.     dcode    4*,x,times2,times4
  671.     move.l    (SP),d0
  672.     asl.l    #2,d0
  673.     move.l    d0,(SP)
  674.     gonext
  675. *
  676.     dcode    8*,x,times4,times8
  677.     move.l    (SP),d0
  678.     asl.l    #3,d0
  679.     move.l    d0,(SP)
  680.     gonext
  681. *
  682.     dcode    2/,x,times8,xdiv2
  683.     move.l    (SP),d0
  684.     asr.l    #1,d0
  685.     move.l    d0,(SP)
  686.     gonext
  687. *
  688. ; ^elem expects base addr on mstack, and an index on pstack
  689.     dcode    (^ELEM),x,xdiv2,pelem    ; return address of array eleme
  690.     move.l    d5,a2    ; pickup base address on mstack
  691.     move.l    (a2),d7    ; base of object in d7
  692.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  693.     clr.l    d1
  694.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  695.     add.l    d1,d7    ; d7 points to idx hdr
  696.     move.w    0(a3,d7.l),d1    ; fetch width word from header
  697.     mulu    2(SP),d1    ; multiply index * width
  698.     add.l    d1,d7    ; add to base address
  699.     addq.l    #4,d7    ; skip the header
  700.     move.l    d7,(SP)    ; leave on data stack
  701.     gonext
  702. *
  703.     dcode    IDXBASE,x,pelem,idxbas    ; idx addr of indexed object
  704.     move.l    d5,a2    ; pickup base address on mstack
  705.     move.l    (a2),d7    ; base of object in d7
  706.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  707.     clr.l    d1
  708.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  709.     add.l    d1,d7    ; d7 points to idx hdr
  710.     addq.l    #4,d7    ; skip the idx hdr
  711.     move.l    d7,-(SP)    ; leave the ^ixdata
  712.     gonext
  713. *
  714.     dcode    LIMIT,x,idxbas,limit    ; limit of indexed object
  715.     move.l    d5,a2    ; pickup base address on mstack
  716.     move.l    (a2),d7    ; base of object in d7
  717.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  718.     clr.l    d1
  719.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  720.     add.l    d1,d7    ; d7 points to idx hdr
  721.     move.w    2(a3,d7.l),-(SP)    ; leave the limit
  722.     clr.w    -(SP)
  723.     gonext
  724. *
  725.     dcode    RANGE?,x,limit,qrange    ; index out of range?
  726.     move.l    d5,a2    ; pickup base address on mstack
  727.     move.l    (a2),d7    ; base of object in d7
  728.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  729.     clr.l    d1
  730.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  731.     add.l    d1,d7    ; d7 points to idx hdr
  732.     clr.l    d0
  733.     move.w    2(a3,d7.l),d0    ; get the limit
  734.     cmp.l    (SP),d0    ; is limit > index?
  735.     sle    d1    ; true if out of range
  736.     neg.b    d1    ; forth boolean
  737.     move.l    d1,-(SP)
  738.     gonext
  739. *
  740. ; at1 treats value as unsigned
  741.     dcode    AT1,x,qrange,at1    ; at opt for byte elements
  742.     move.l    d5,a2    ; pickup base address on mstack
  743.     move.l    (a2),d7    ; base of object in d7
  744.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  745.     clr.l    d1
  746.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  747.     add.l    d1,d7    ; d7 points to idx hdr
  748.     add.l    (SP),d7    ; add the index
  749.     clr.l    d0
  750.     move.b    4(a3,d7.l),d0    ; fetch addr+4 (for idx hdr)
  751.     move.l    d0,(SP)
  752.     gonext
  753. *
  754.     dcode    AT2,x,at1,at2    ; at opt for byte elements
  755.     move.l    d5,a2    ; pickup base address on mstack
  756.     move.l    (a2),d7    ; base of object in d7
  757.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  758.     clr.l    d1
  759.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  760.     add.l    d1,d7    ; d7 points to idx hdr
  761.     move.l    (SP),d0    ; get the index
  762.     lsl.w    #1,d0    ; index * 2
  763.     add.l    d0,d7    ; add the index
  764.     move.w    4(a3,d7.l),d1    ; fetch addr+4 (for idx hdr)
  765.     ext.l    d1    ; sign extend
  766.     move.l    d1,(sp)
  767.     gonext
  768. *
  769.     dcode    AT4,x,at2,at4    ; at opt for long elements
  770.     move.l    d5,a2    ; pickup base address on mstack
  771.     move.l    (a2),d7    ; base of object in d7
  772.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  773.     clr.l    d1
  774.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  775.     add.l    d1,d7    ; d7 points to idx hdr
  776.     move.l    (SP),d0    ; get the index
  777.     lsl.w    #2,d0    ; index * 4
  778.     add.l    d0,d7    ; add the index
  779.     move.l    4(a3,d7.l),(SP)    ; fetch addr+4 (for idx hdr)
  780.     gonext
  781. *
  782.     dcode    TO1,x,at4,to1    ; To opt for byte elements
  783.     move.l    d5,a2    ; pickup base address on mstack
  784.     move.l    (a2),d7    ; base of object in d7
  785.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  786.     clr.l    d1
  787.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  788.     add.l    d1,d7    ; d7 points to idx hdr
  789.     add.l    (SP)+,d7    ; add the index
  790.     move.l    (SP)+,d0
  791.     move.b    d0,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  792.     gonext
  793. *
  794.     dcode    TO2,x,to1,to2    ; To opt for byte elements
  795.     move.l    d5,a2    ; pickup base address on mstack
  796.     move.l    (a2),d7    ; base of object in d7
  797.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  798.     clr.l    d1
  799.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  800.     add.l    d1,d7    ; d7 points to idx hdr
  801.     move.l    (SP)+,d0    ; get the index
  802.     lsl.w    #1,d0    ; index * 2
  803.     add.l    d0,d7    ; add the index
  804.     move.l    (sp)+,d1
  805.     move.w    d1,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  806.     gonext
  807. *
  808.     dcode    TO4,x,to2,to4    ; to opt for long elements
  809.     move.l    d5,a2    ; pickup base address on mstack
  810.     move.l    (a2),d7    ; base of object in d7
  811.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  812.     clr.l    d1
  813.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  814.     add.l    d1,d7    ; d7 points to idx hdr
  815.     move.l    (SP)+,d0    ; get the index
  816.     lsl.w    #2,d0    ; index * 4
  817.     add.l    d0,d7    ; add the index
  818.     move.l    (SP)+,4(a3,d7.l)    ; store to addr+4 (for idx hdr)
  819.     gonext
  820. *
  821.     dcode    ++4,x,to4,inc4    ; inc opt for long elements
  822.     move.l    d5,a2    ; pickup base address on mstack
  823.     move.l    (a2),d7    ; base of object in d7
  824.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  825.     clr.l    d1
  826.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  827.     add.l    d1,d7    ; d7 points to idx hdr
  828.     move.l    (SP)+,d0    ; get the index
  829.     lsl.w    #2,d0    ; index * 4
  830.     add.l    d0,d7    ; add the index
  831.     move.l    (SP)+,d1    ; get increment
  832.     add.l    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  833.     gonext
  834. *
  835.     dcode    ++2,x,inc4,inc2    ; inc opt for word elements
  836.     move.l    d5,a2    ; pickup base address on mstack
  837.     move.l    (a2),d7    ; base of object in d7
  838.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  839.     clr.l    d1
  840.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  841.     add.l    d1,d7    ; d7 points to idx hdr
  842.     move.l    (SP)+,d0    ; get the index
  843.     lsl.w    #1,d0    ; index * 4
  844.     add.l    d0,d7    ; add the index
  845.     move.l    (SP)+,d1    ; get increment
  846.     add.w    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  847.     gonext
  848. *
  849.     dcode    ++1,x,inc2,inc1    ; inc opt for byte elements
  850.     move.l    d5,a2    ; pickup base address on mstack
  851.     move.l    (a2),d7    ; base of object in d7
  852.     move.l    -4(a3,d7.l),d0    ; d0 has ^class of object
  853.     clr.l    d1
  854.     move.w    18(a3,d0.l),d1    ; d1 has dlen of object
  855.     add.l    d1,d7    ; d7 points to idx hdr
  856.     move.l    (SP)+,d0    ; get the index
  857.     add.l    d0,d7    ; add the index
  858.     move.l    (SP)+,d1    ; get increment
  859.     add.b    d1,4(a3,d7.l)    ; inc addr+4 (for idx hdr)
  860.     gonext
  861. *
  862. ; fast left lshift ( val #shift -- val )
  863.     dcode    <<,x,inc1,shfl
  864.     popd0
  865.     popd1
  866.     lsl.l    d0,d1
  867.     move.l    d1,-(SP)
  868.     gonext
  869. *
  870. ; fast right lshift ( val #shift -- val )
  871.     dcode    >>,x,shfl,shfr
  872.     popd0
  873.     popd1
  874.     lsr.l    d0,d1
  875.     move.l    d1,-(SP)
  876.     gonext
  877. *
  878.     dcode    (ABS),x,shfr,abs_    ; leave absolute of mstack addr
  879.     move.l    d5,a2
  880.     move.l    (a2),d0
  881.     add.l    a3,d0
  882.     move.l    d0,-(SP)
  883.     gonext
  884. *
  885.     dcode    COUNT,x,abs_,count
  886.     move.l    (SP),d0
  887.     add.l    #1,(SP)
  888.     clr.l    d1
  889.     move.b    0(A3,d0.l),d1
  890.     move.l    d1,-(SP)
  891.     gonext
  892. *
  893.     dcode    DEPTH,x,count,depth
  894.     move.l    SP,d0
  895.     sub.l    a3,d0
  896.     move.l    #(s09-origin),d7
  897.     sub.l    0(a3,d7.l),d0
  898.     neg.l    d0
  899.     asr.l    #2,d0
  900.     pushD0
  901.     gonext
  902. *
  903.     dcode    FILL,x,depth,fil
  904.     popD0
  905. fill1    popD1
  906.     move.l    (SP)+,d7
  907.     l,hld,pad,over,subt,semis
  908. *
  909.     dcol    HOLD,x,enum,hold
  910.     DATA    pmone-origin
  911.     cfas    hld1,hld,cstore,semis
  912. *
  913.     dcol    SIGN,x,hold,sign
  914.     cfas    rot,zless
  915.     if.    Z3
  916.     mlit    $2d
  917.     cfas    hold
  918.     then.    Z3
  919.     cfas    semis
  920. *
  921.     dcol    #,x,sign,sharp
  922.     cfas    base,msmod,rot
  923.     mlit    9
  924.     cfas    over,less
  925.     if.    Z4
  926.     mlit    7
  927.     cfas    plus
  928.     then.    Z4
  929.     mlit    $30
  930.     cfas    plus,hold,semis
  931. *
  932.     dcol    #S,x,sharp,sharps
  933.     begin.    Z5
  934.     cfas    sharp,dup2,or_,zequ
  935.     until.    Z5
  936.     cfas    semis
  937. *
  938.     dcol    <#,x,sharps,snum
  939.     cfas    pad,hld2,semis
  940. *
  941.     dcol    D.R,x,snum,ddotr
  942.     cfas    toR,swap_,over,dabs,snum,sharps,sign,enum,rfrom
  943.     cfas    over,subt,spaces,type,semis
  944. *
  945.     dcol    D.,x,ddotr,ddot
  946.     mlit    0
  947.     cfas    ddotr,space,semis
  948. *
  949.     dcol    .,x,ddot,dot
  950.     cfas    sToD,ddot,semis
  951. *
  952.     dcol    U.,x,dot,udot
  953.     mlit    0
  954.     cfas    ddot,semis
  955. *
  956.     dcol    .R,x,udot,dotR
  957.     cfas    toR,sToD,rfrom,ddotr,semis
  958. *
  959.     dcol    ?,x,dotR,quest
  960.     cfas    fetch,dot,semis
  961. *
  962.     dcol    SPACE,x,quest,space
  963.     cfas    bl,emit,semis
  964. *
  965.     dcol    SPACES,x,space,spaces
  966.     mlit    0
  967.     do.    Z7
  968.     cfas    bl,emit
  969.     loop.    Z7
  970.     cfas    semis
  971. *
  972.     dcol    -TRAILING,x,spaces,mtrail
  973.     cfas    dup
  974.     mlit    0
  975.     do.    Z8
  976.     cfas    over,over,plus,min1,cfetch,bl,subt
  977.     eif.    Z10
  978.     cfas    leave
  979.     else.    Z10
  980.     cfas    min1
  981.     ethen.    Z10
  982.     loop.    Z8
  983.     cfas    semis
  984. *
  985.     dcol    N>COUNT,x,mtrail,ncount
  986.     cfas    count
  987.     mlit    $1f
  988.     cfas    and_,semis
  989. *
  990.     dcol    ID.,x,ncount,iddot
  991.     cfas    ncount,type,space,semis
  992. *
  993.     dcol    EMIT,x,iddot,emit
  994.     cfas    dup,emitvec,pemitv,pone     ; send the char via Quickdraw
  995.     cfas    out1,semis
  996. *
  997.     dcol    TYPE,x,emit,type
  998.     cfas    dup,out1,dup2,typevec,ptypev,semis
  999.     dcol    CR,x,type,cr
  1000.     cfas    crvec,pcrvec,semis
  1001. *
  1002.     dcol    CONTBOT,x,cr,contbot
  1003.     cfas    port_,lit,windowsize+origin,plus,plus4
  1004.     cfas    wfetch,semis
  1005. *
  1006.     dcol    CONTTOP,x,contbot,conttop
  1007.     cfas    port_,lit,windowsize+origin,plus
  1008.     cfas    wfetch,semis
  1009. *
  1010.     dcol    ?LEAD,x,conttop,qlead    ; return proper leading for fo
  1011.     cfas    port_,lit,txsize+origin,plus,wfetch
  1012.     cfas    lit,120+origin,star,lit,50+origin,plus    ; Increase 120 f
  1013.     cfas    lit,100+origin,slash,semis
  1014. *
  1015.     dcol    ?LINES,x,qlead,qlines    ; number of even lines in port
  1016.     cfas    qlead,contbot,conttop    ; bottom-top of content rgn
  1017.     cfas    subt,lit,5+origin,subt,    ; less first line location
  1018.     cfas    over,plus1,subt    ; minus ?LEAD+1
  1019.     cfas    swap_,slash,semis    ; divided by ?LEAD
  1020. *
  1021.     dcol    BOTTOM,x,qlines,scrbot    ; coordinate of screen bottom
  1022.     cfas    conttop,plus4,qlead,qlines,star,plus
  1023.     cfas    semis
  1024. *
  1025.     dcol    (CR),x,scrbot,cr_    ; simulate a CR in Quickdraw
  1026.     cfas    dotcur,fetxy,swap_,drop,lit,8+origin,swap_
  1027.     cfas    dup,scrbot,grt
  1028.     eif.    x27
  1029.     cfas    pzer,qlead,minus,scroll,gotoxy
  1030.     else.    x27
  1031.     cfas    qlead,plus
  1032.     cfas    gotoxy
  1033.     ethen.    x27
  1034.     cfas    dotcur,semis
  1035. *
  1036.     dcol    (BS),x,cr_,bs_
  1037.     cfas    dotcur,fetxy,swap_,lit,6+origin,subt,lit,8+origin,max
  1038.     cfas    swap_,dup2,gotoxy,curs_,pzer,curs_2
  1039.     cfas    bl,emit,curs_2,gotoxy,dotcur,semis
  1040. *
  1041.     dcol    ?TERMINAL,x,bs_,qterm
  1042.     cfas    lit,$28+origin,qevt,semis
  1043. *
  1044.     dcol    (KEY),x,qterm,key_
  1045.     mlit    $2A        ; kbd and mouse events
  1046.     cfas    getevt,lit,2+origin,grt
  1047.     eif.    Z100
  1048.     cfas    ftemsg,lit,$00ff+origin,and_
  1049.     else.    Z100
  1050.     cfas    pmone
  1051.     ethen.    Z100
  1052.     cfas    semis
  1053. *
  1054.     dcol    (DKEY),x,key_,dkey_
  1055.     cfas    ufcb,pone,lit,ftwork    ; read 1 char from disk
  1056.     cfas    read_,dup,dkerr2
  1057.     eif.    y10
  1058.     cfas    keystor,pone,curs_2    ; restore to terminal if err
  1059.     cfas    lit,13+origin
  1060.     else.    y10
  1061.     cfas    lit,ftwork,cfetch    ; leav char on stack
  1062.     ethen.    y10
  1063.     cfas    qpause,semis
  1064. *
  1065.     dcol    KEY!,x,dkey_,keystor    ; reset KEY to keyboard
  1066.     cfas    lit,key_,keyvec2,semis
  1067. *
  1068.     dcol    KEY,x,keystor,key
  1069.     cfas    keyvec,semis    ; vectored key
  1070. *
  1071.     dcol    <",x,key,diskin    ; set to disk key inpu
  1072.     cfas    ufcb,close_,dot    ; close the oldfile
  1073.     cfas    lit,useFcb,lit,80+origin,era,pzer,curs_2
  1074.     cfas    lit,34+origin,word,here,dup,cfetch,plus1
  1075.     cfas    lit,useFname,swap_,cmove
  1076.     cfas    lit,useFname,basadr,lit,useFcb,sflptr
  1077.     cfas    ufcb,pone,open_,dot
  1078.     cfas    cr,lit,dkey_,keyvec2,semis
  1079. *
  1080. ; ------------ Disk words for FORTH screen handling
  1081.     dcol    !FPTR,x,diskin,sflptr    ; ( ^fname pblock -- )
  1082.     cfas    lit,18+origin,plus,store,semis
  1083. *
  1084.     dcol    ?COMP,x,sflptr,qcomp
  1085.     cfas    state,zequ,abq_
  1086.     STR    "compilation only "
  1087.     cfas    semis
  1088. *
  1089.     dcol    ?DP,x,qcomp,qdp    ; dp grown into heap?
  1090.     cfas    room,pone,less,abq_
  1091.     STR    " out of room "
  1092.     cfas    semis
  1093. *
  1094.     dcol    ?STACK,x,qdp,qstack
  1095.     cfas    spfet,s0,swap_,uless
  1096.     cfas    abq_
  1097.     STR    "empty stack  "
  1098.     cfas    semis
  1099. *
  1100.     dcol    ?EXEC,x,qstack,qexec
  1101.     cfas    state,cstate,or_,abq_    ; err if class or forth compile
  1102.     STR    "run state only "
  1103.     cfas    semis
  1104. *
  1105.     dcol    ?PAIRS,x,qexec,qpairs
  1106.     cfas    subt,abq_
  1107.     STR    "unpaired conditionals  "
  1108.     cfas    semis
  1109. *
  1110.     dcol    ?CSP,x,qpairs,qcsp
  1111.     cfas    spfet,csp,subt,abq_
  1112.     STR    "definition not finished  "
  1113.     cfas    semis
  1114. *
  1115.     dcol    (NUMBER),x,qcsp,num_
  1116.     begin.    Z27
  1117.     cfas    plus1,dup,tor,cfetch,base,digit
  1118.     while.    Z27
  1119.     cfas    swap_,base,ustar,drop,rot,base
  1120.     cfas    ustar,dplus,dpl,plus1
  1121.     if.    Z28
  1122.     cfas    pone,dpl1
  1123.     then.    Z28
  1124.     cfas    rfrom
  1125.     repeat.    Z27
  1126.     cfas    rfrom,semis
  1127. *
  1128.     dcol    ?NUM,x,num_,qnum    ; ( addr -- d t OR f )
  1129.     cfas    pzer,pzer,rot,dup,plus1,cfetch
  1130.     mlit    $2d
  1131.     cfas    equals,dup,tor,plus,pmone
  1132.     begin.    Z30
  1133.     cfas    dpl2,num_,dup,cfetch,bl,subt
  1134.     while.    Z30
  1135.     cfas    dup,cfetch,lit,$2e+origin,subt
  1136.     if.    zz177
  1137.     cfas    rfrom,drop2,drop2,pzer,semis
  1138.     then.    zz177
  1139.     cfas    pzer
  1140.     repeat.    Z30
  1141.     cfas    drop,rfrom
  1142.     if.    Z31
  1143.     cfas    dminus
  1144.     then.    Z31
  1145.     cfas    pone,semis
  1146. *
  1147.     dcol    NUMBER,x,qnum,number    ; ( addr -- d )
  1148.     cfas    qnum,zequ,abq_
  1149.     STR    "not found  "
  1150.     cfas    semis
  1151. *
  1152.     dcol    LITERAL,I,number,liter
  1153.     cfas    state
  1154.     if.    Z32
  1155.     cfas    dup,lit
  1156.     DATA    $10000
  1157.     cfas    less,over,zless,zequ,and_
  1158.     eif.    zz39
  1159.     cfas    comp,wlit,wcomma
  1160.     else.    zz39
  1161.     cfas    comp,lit,comma    ; builds word lit if n>=0 and n<$10000
  1162.     ethen.    zz39
  1163.     then.    Z32
  1164.     cfas    semis
  1165. *
  1166.     dcol    EXPECT,x,liter,expect
  1167.     cfas    over,plus,over
  1168.     do.    Z33
  1169.     cfas    key,dup,lit,8+origin,equals    ; bs ?
  1170.     eif.    Z34
  1171.     cfas    drop,dup,i,equals,dup,rfrom,min2,plus,tor
  1172.     eif.    Z35
  1173.     cfas    lit,10+origin,beep
  1174.     else.    Z35
  1175.     cfas    bs_
  1176.     ethen.    Z35
  1177.     cfas    pzer
  1178.     else.    Z34
  1179.     cfas    dup,zequ
  1180.     if.    y118
  1181.     cfas    drop,lit,32+origin    ; map null to space
  1182.     then.    y118
  1183.     cfas    dup,lit,$0d+origin,equals
  1184.     eif.    Z36
  1185.     cfas    leave,drop,pzer,pzer,cr
  1186.     else.    Z36
  1187.     cfas    dup
  1188.     ethen.    Z36
  1189.     cfas    r,cstore,pzer,r,plus1,cstore
  1190.     ethen.    Z34
  1191.     cfas    echovec
  1192.     loop.    Z33
  1193.     cfas    drop,semis
  1194. *
  1195.     dcol    WORD,x,expect,word
  1196.     cfas    tib
  1197.     cfas    in,plus,swap_,enclos
  1198.     cfas    word_,semis
  1199. *
  1200.     dcol    WORD",x,word,wordq    ; lower-case version of word
  1201.     cfas    tib,in,plus,lit,34+origin,enclos
  1202.     cfas    lcword,here,semis
  1203. *
  1204.     dcol    FIND,x,wordq,mfind
  1205.     cfas    bl,word,ufind,dup,zequ
  1206.     if.    w72
  1207.     cfas    drop,here,contxt,fetch
  1208.     cfas    find_,dup,zequ
  1209.     if.    Z38
  1210.     cfas    contxt,currnt,subt
  1211.     if.    Z40
  1212.     cfas    drop,here,latest,find_
  1213.     then.    Z40
  1214.     then.    Z38
  1215.     then.    w72
  1216.     cfas    semis
  1217. *
  1218.     ADJST        ; X - null word
  1219. lkx    DC.B    $C1
  1220.     DC.B    $00
  1221.     DATA    lkmfind-origin
  1222.     DATA    colcode-origin    ; not Fig standard -
  1223.     cfas    rfrom,drop    ; note: doesn't support Forth screens
  1224.     cfas    semis
  1225. *
  1226.     dcol    "S,",x,x,scomma    ; begin S, dict entry
  1227.     cfas    here,dup,cfetch,plus1,dup
  1228.     cfas    allot,pone,and_
  1229.     if.    sc10
  1230.     cfas    pzer,ccomma
  1231.     then.    sc10
  1232.     cfas    dup,rot,toggle,semis
  1233. *
  1234.     dcol    (CREATE),x,scomma,creat_
  1235.     cfas    here,pone,and_
  1236.     if.    Z430
  1237.     cfas    pzer,ccomma
  1238.     then.    Z430
  1239.     cfas    docs
  1240.     if.    Z410
  1241.     cfas    line_,wcomma
  1242.     then.    Z410
  1243.     cfas    mfind
  1244.     if.    Z420
  1245.     cfas    drop,nfa,iddot,dotq_
  1246.     STR    "is redefined "
  1247.     cfas    cr
  1248.     then.    Z420
  1249.     cfas    lit,$80+origin,scomma
  1250.     cfas    latest,comma,currnt
  1251.     cfas    store,here,plus4,comma,semis
  1252. *
  1253.     dcol    (INTRP),x,creat_,intrp_
  1254.     begin.    Z43
  1255.     cfas    mfind
  1256.     eif.    Z44
  1257.     cfas    state,less
  1258.     eif.    Z45
  1259.     cfas    cfa,comma
  1260.     else.    Z45
  1261.     cfas    cfa,exec
  1262.     ethen.    Z45
  1263.     else.    Z44
  1264.     cfas    here,number,dpl,plus1
  1265.     eif.    Z46
  1266.     cfas    dliter
  1267.     else.    Z46
  1268.     cfas    drop,liter
  1269.     ethen.    Z46
  1270.     ethen.    Z44
  1271.     cfas    qdp,qstack
  1272.     again.    Z43
  1273.     cfas    semis
  1274. *
  1275.     dcol    !CSP,x,intrp_,stcsp
  1276.     cfas    spfet,csp2,semis
  1277. *
  1278.     dcol    QUERY,x,stcsp,query
  1279.     cfas    tib,lit,$99+origin
  1280.     cfas    expvec,pzer,in2,semis
  1281. *
  1282.     dcol    <[,I,query,lbrak
  1283.     mlit    0
  1284.     cfas    state2,semis
  1285. *
  1286.     dcol    ]>,x,lbrak,rbrak
  1287.     mlit    $c0
  1288.     cfas    state2,semis
  1289. *
  1290.     dcol    DEFINITIONS,x,rbrak,defs
  1291.     cfas    contxt,currnt2,semis
  1292. *
  1293.     dcol    <BUILDS,x,defs,builds
  1294.     mlit    0
  1295.     cfas    const,semis
  1296. *
  1297.     dcol    OK,x,builds,ok
  1298.     cfas    depth,ptwo,dotr,base,dup
  1299.     cfas    lit,10+origin,equals
  1300.     eif.    xx11
  1301.     cfas    lit,45+origin,emit
  1302.     else.    xx11
  1303.     cfas    dup,lit,16+origin,equals
  1304.     eif.    xx12
  1305.     cfas    lit,36+origin,emit
  1306.     else.    xx12
  1307.     cfas    lit,63+origin,emit
  1308.     ethen.    xx12
  1309.     ethen.    xx11
  1310.     cfas    drop,lit,62+origin,emit
  1311.     cfas    semis
  1312. *
  1313.     dcode    Q,x,ok,q_
  1314.     clr.w    -(sp)
  1315.     _hilitemenu
  1316.     gonext
  1317. *
  1318.     dcol    QUIT,x,ok,quit
  1319.     cfas    pzer,in2
  1320.     cfas    lbrak,quvec,q_
  1321.     cfas    cr,ok
  1322.     begin.    Z48
  1323.     cfas    qdp,rpstor,query,interp,state,zequ
  1324.     if.    Z50
  1325.     cfas    ok
  1326.     then.    Z50
  1327.     again.    Z48
  1328.     cfas    semis
  1329. *
  1330.     dcol    BACK,x,quit,back
  1331.     cfas    here,subt,comma,semis
  1332. *
  1333.     dcol    FWD,x,back,fwd    ; fill in fwd branch
  1334.     cfas    here,over,subt,swap_,store,semis
  1335. *
  1336.     dcol    BEGIN,I,fwd,begin
  1337.     cfas    qcomp,here,pone,semis
  1338. *
  1339.     dcol    THEN,I,begin,then
  1340.     cfas    qcomp,lit,2+origin,qpairs,fwd,semis
  1341. *
  1342.     dcol    DO,I,then,do    ; compiles fwd branch for smart exit
  1343.     cfas    comp,do_,here,pzer,comma,lit,3+origin,semis
  1344. *
  1345.     dcol    LOOP,I,do,loop
  1346.     cfas    lit,3+origin,qpairs,comp,loop_,dup,plus4,back
  1347.     cfas    fwd,semis
  1348. *
  1349.     dcol    +LOOP,I,loop,ploop
  1350.     cfas    lit,3+origin,qpairs,comp,ploop_,dup,plus4,back
  1351.     cfas    fwd,semis
  1352. *
  1353.     dcol    COMPILE,x,ploop,comp
  1354.     cfas    qcomp,rfrom,dup,plus4
  1355.     cfas    tor,fetch,comma,semis
  1356.     dcol    [COMPILE],I,comp,bcomp
  1357.     cfas    fetpfa,cfa,comma,semis
  1358. *
  1359.     dcol    DLITERAL,I,bcomp,dliter
  1360.     cfas    state
  1361.     if.    Z51
  1362.     cfas    swap_,liter,liter
  1363.     then.    Z51
  1364.     cfas    semis
  1365. *
  1366.     dcol    UNTIL,I,dliter,until
  1367.     cfas    pone,qpairs,comp,bran0,back,semis
  1368. *
  1369.     dcol    AGAIN,I,until,again
  1370.     cfas    pone,qpairs,comp,bran,back,semis
  1371. *
  1372.     dcol    REPEAT,I,again,repeat
  1373.     cfas    tor,tor,again,rfrom,rfrom,min2
  1374.     cfas    then,semis
  1375. *
  1376.     dcol    IF,I,repeat,xif
  1377.     cfas    comp,bran0,here,pzer,comma,lit,2+origin,semis
  1378. *
  1379.     dcol    ELSE,I,xif,xelse
  1380.     cfas    lit,2+origin,qpairs,comp,bran,here,pzer,comma
  1381.     cfas    swap_,lit,2+origin,then,lit,2+origin,semis
  1382. *
  1383.     dcol    WHILE,I,xelse,while
  1384.     cfas    xif,plus2,semis
  1385. *
  1386.     dcol    EXIT,I,while,exit
  1387.     cfas    latest,pfa,cfa,fetch    ; is this a pcolon def?
  1388.     cfas    lit,pcolcode,equals
  1389.     eif.    se10
  1390.     cfas    comp,semip    ; yes, put in parm denester
  1391.     else.    se10
  1392.     cfas    comp,semis
  1393.     ethen.    se10
  1394.     cfas    semis
  1395. *
  1396.     dcol    ;,I,exit,semi    ; immediate - semicolon def
  1397.     cfas    qcsp,exit,lbrak,semis
  1398. *
  1399.     dcol    .",I,semi,dotq
  1400.     cfas    state
  1401.     eif.    Z52
  1402.     cfas    comp,dotq_
  1403.     cfas    wordq    ; lower-case word
  1404.     cfas    cfetch,plus1,aline,allot
  1405.     else.    Z52
  1406.     cfas    wordq,count,type
  1407.     ethen.    Z52
  1408.     cfas    semis
  1409. *
  1410.     dcol    IMMEDIATE,x,dotq,immed
  1411.     cfas    latest,lit,$40+origin,toggle,semis
  1412. *
  1413.     dcol    LATEST,x,immed,latest
  1414.     cfas    currnt,fetch,semis
  1415. *
  1416.     dcol    (,I,latest,lparen
  1417.     cfas    lit,$29+origin,word,semis
  1418. *
  1419.     ADJST    
  1420. lktick    DC.B    $c1    ; tick
  1421.     DC.B    $27
  1422.     DATA    lklparen-origin
  1423. tick    DATA    colcode-origin
  1424.     cfas    fetpfa,liter,semis
  1425. *
  1426.     dcol    FORGET,x,tick,forget
  1427.     cfas    defs    ; set current to context
  1428.     cfas    tick,dup,fence,uless,abq_
  1429.     STR    "in protected dictionary  "
  1430.     cfas    dup,nfa,dp2,lfa,fetch,currnt    ; leave line# if sources on
  1431.     cfas    store,semis    ; otherwise might forget nec stuff
  1432. *
  1433.     dcol    ROOM,x,forget,room    ; leave dict space left
  1434.     cfas    msiz,fetch,dp,bdp,fetch
  1435.     cfas    subt,subt,semis
  1436. *
  1437.     dcol    GREET,x,room,greet
  1438.     cfas    cls
  1439.     mlit    hello-origin
  1440.     cfas    count,type,cr
  1441.     mlit    bytesleft-origin
  1442.     cfas    count,type
  1443.     cfas    room,dot,cr,semis
  1444. *
  1445.     dcol    COLD,x,greet,xcold
  1446.     cfas    lit,aregn,fetch,zequ
  1447.     if.    w59
  1448.     cfas    intool    ; only if we haven't gotten heap already
  1449.     then.    w59
  1450.     cfas    lit,inits0,fetch,s02,lit,initr0,fetch,r02
  1451.     cfas    lit,initfenc,fetch,fence2,lit,initvocl,fetch,vocl2
  1452.     cfas    lit,initdp,fetch,dp2,lit,initmp,fetch,m02
  1453.     cfas    lit,initlast,fetch,lit,forth_
  1454.     cfas    lit,$0a+origin,plus,store,decim,spstor,mpstor    \ careful on the 0a
  1455.     cfas    forth_,defs,pzer,warn2,objini,greet,quit,semis
  1456. *
  1457.     dcol    .PAUSE,x,xcold,dpause
  1458.     cfas    lit,pausemsg,count,type,semis
  1459. *
  1460.     dcol    ?PAUSE,x,dpause,qpause    ; check if user wants to stop
  1461.     cfas    qterm
  1462.     if.    w43
  1463.     cfas    key_,drop,cr,dpause
  1464.     cfas    key_,cr,lit,0+origin,out2,lit,32+origin,grt
  1465.     if.    w44
  1466.     cfas    abort
  1467.     then.    w44
  1468.     then.    w43
  1469.     cfas    semis
  1470. *
  1471.     dcol    ABORT,x,qpause,abort
  1472.     cfas    cr
  1473.     cfas    spstor,mpstor,lit,key_,keyvec2,decim
  1474.     cfas    pone,curs_2,qstack,lbrak,forth_
  1475.     cfas    defs,abvec
  1476.     cfas    lit,$a850+origin,trap_    ; initCursor
  1477.     cfas    quit,semis
  1478. *
  1479.     ddoes    YERK,x,abort,forth_,dovocab    ; FORTH vocabulary
  1480.     DC.W    $8120
  1481. vlf    DATA    lastdef-origin
  1482.     DATA    0
  1483. *
  1484.     dcol    .VAL,x,forth_,dotval
  1485.     cfas    dotr,lit,2+origin,spaces,semis
  1486. *
  1487.     dcol    ?CFA,x,dotval,qcfa
  1488.     cfas    dup,plus4,nfa,ncount
  1489.     cfas    tor,r,plus,plus4,aline
  1490.     cfas    over,equals,rfrom,land_,semis
  1491. *
  1492.     dcol    (.STACK),x,qcfa,dstak_
  1493.     cfas    base,lit,ftwork1,store,dup2,grt    ; preserve current base
  1494.     eif.    z61
  1495.     do.    z62
  1496.     cfas    cr,ifetch,dup,decim
  1497.     cfas    lit,8+origin,dotval,dup,hex,lit,36+origin,emit
  1498.     cfas    pzer,lit,6+origin,ddotr
  1499.     cfas    lit,3+origin,spaces,aline,min4,plus1,false
  1500.     eif.    z63
  1501.     cfas    plus4,nfa,iddot
  1502.     else.    z63
  1503.     cfas    drop
  1504.     ethen.    z63
  1505.     cfas    pfour
  1506.     ploop.    z62
  1507.     else.    z61
  1508.     cfas    lit,emptymsg,count,type,less
  1509.     cfas    abq_
  1510.     STR    "Stack Underflow  "
  1511.     ethen.    z61
  1512.     cfas    lit,ftwork1,fetch,base2,cr    restore base
  1513.     cfas    semis
  1514. *
  1515. Lastdef    dcol    .S,x,dstak_,dots
  1516.     cfas    spfet,s0,swap_,lit,dsmsg
  1517.     cfas    count,type,dstak_,r0,rpfet,lit,rsmsg
  1518.     cfas    count,type,dstak_,m0,mpfet,lit,msmsg
  1519.     cfas    count,type,dstak_
  1520.     cfas    semis
  1521. *
  1522. nextdef    EQU    *
  1523.     ENDR
  1524. *
  1525.     SEG    0,32,VAR.LEN,$20
  1526. SEG0
  1527. SEG_1    JP    start,1
  1528.     JP    getInstL,1
  1529. END_1
  1530. SEG_2    JP    origin,2
  1531.     JP    coldvec,2
  1532.     JP    getDict,2
  1533. END_2
  1534. END0
  1535.     ENDR
  1536. *
  1537. *    END
  1538.     RSRC    YERK,0,32
  1539.     STR     "Yerk Version 3.6.7"
  1540.     ENDR
  1541. *
  1542.     RSRC    FREF,128,32
  1543.     ASC    'APPL'
  1544.     DATA    /0
  1545.     STR    ""
  1546.     ENDR
  1547. *
  1548.     RSRC    FREF,129,32
  1549.     ASC    'COM '
  1550.     DATA    /1
  1551.     STR    ""
  1552.     ENDR
  1553. *
  1554.     RSRC    FREF,130,32
  1555.     ASC 'USER'
  1556.     DATA /2
  1557.     STR    ""
  1558.     ENDR
  1559. *
  1560.     RSRC    FREF,131,32
  1561.     ASC    'BIN '
  1562.     DATA /3
  1563.     STR    ""
  1564.     ENDR
  1565. *
  1566.     RSRC    FREF,132,32
  1567.     ASC    'TEXT'
  1568.     DATA /4
  1569.     STR    ""
  1570.     ENDR
  1571. *
  1572.     RSRC    ICN#,128,32
  1573.     HEX    71c0.0000.cb20.0000
  1574.     HEX    c620.0000.6040.0000
  1575.     HEX    3080.0000.1900.1f80
  1576.     HEX    1900.2040.197e.4020
  1577.     HEX    1981.9810.1e8e.e408
  1578.     HEX    0ccf.3f87.3069.1803
  1579.     HEX    c864.8003.c864.4003
  1580.     HEX    c8c8.f003.c99f.8ff3
  1581.     HEX    c981.990f.c9ff.9903
  1582.     HEX    c8fd.8200.c801.8400
  1583.     HEX    c801.8200.c801.91ce
  1584.     HEX    c801.9939.c801.9f32
  1585.     HEX    c801.d724.c800.e308
  1586.     HEX    c800.0304.cfff.e322
  1587.     HEX    c000.1331.c000.1339
  1588.     HEX    ffff.e3ef.7fff.c1c6
  1589. *
  1590.     HEX    71c0.0000.fbe0.0000
  1591.     HEX    ffe0.0000.7fc0.0000
  1592.     HEX    3f80.0000.1f00.1f80
  1593.     HEX    1f00.3fc0.1f7e.7fe0
  1594.     HEX    1fff.fff0.1ffe.e7f8
  1595.     HEX    0fff.ffff.3ff9.ffff
  1596.     HEX    fffc.ffff.fffc.7fff
  1597.     HEX    fff8.ffff.ffff.ffff
  1598.     HEX    ffff.ff0f.ffff.ff03
  1599.     HEX    ffff.fe00.ffff.fc00
  1600.     HEX    ffff.fe00.ffff.ffce
  1601.     HEX    ffff.ffff.ffff.fffe
  1602.     HEX    ffff.fffc.ffff.fff8
  1603.     HEX    ffff.fffc.ffff.fffe
  1604.     HEX    ffff.ffff.ffff.c1ff
  1605.     HEX    ffff.c1ef.7fff.c1c6
  1606.     ENDR
  1607. *
  1608.     RSRC    ICN#,129,32
  1609.     HEX    71c7.fffe.cb2c.0001
  1610.     HEX    c62c.0001.604f.fff9
  1611.     HEX    3087.fff9.1900.0019
  1612.     HEX    1900.0019.197e.0019
  1613.     HEX    1981.0019.1e8e.0019
  1614.     HEX    0ccc.0019.3068.0019
  1615.     HEX    c864.0019.c864.0019
  1616.     HEX    c8c8.fc19.c99f.8219
  1617.     HEX    c981.9919.c9ff.9919
  1618.     HEX    c8fd.821f.c801.840e
  1619.     HEX    c801.8200.c801.91ce
  1620.     HEX    c801.9939.c801.9f32
  1621.     HEX    c801.d724.c800.e308
  1622.     HEX    c800.0304.cfff.e322
  1623.     HEX    c000.1331.c000.1339
  1624.     HEX    ffff.e3ef.7fff.c1c6
  1625. *
  1626.     HEX    71c7.fffe.fbef.ffff
  1627.     HEX    ffef.ffff.7fcf.ffff
  1628.     HEX    3fff.ffff.1fff.ffff
  1629.     HEX    1fff.ffff.1fff.ffff
  1630.     HEX    1fff.ffff.1fff.ffff
  1631.     HEX    0fff.ffff.3fff.ffff
  1632.     HEX    ffff.ffff.ffff.ffff
  1633.     HEX    ffff.ffff.ffff.ffff
  1634.     HEX    ffff.ffff.ffff.ffff
  1635.     HEX    ffff.ffff.ffff.ffff
  1636.     HEX    ffff.fff8.ffff.ffff
  1637.     HEX    ffff.ffff.ffff.ffff
  1638.     HEX    ffff.fffe.ffff.fffc
  1639.     HEX    ffff.fffc.ffff.fffe
  1640.     HEX    ffff.f3ff.ffff.f3ff
  1641.     HEX    ffff.e3ef.7fff.c1c6
  1642.     ENDR
  1643. *
  1644.     RSRC    ICN#,130,32
  1645.     HEX    71c7.fffe.cb2c.0001
  1646.     HEX    c62c.0001.604f.fff9
  1647.     HEX    3087.fff9.1900.0019
  1648.     HEX    1900.0019.1900.0019
  1649.     HEX    1900.0019.1e00.0019
  1650.     HEX    0c00.0019.3000.0019
  1651.     HEX    c800.0019.c800.0019
  1652.     HEX    c800.0019.c800.0019
  1653.     HEX    c800.0019.c800.0019
  1654.     HEX    c800.001f.c800.000f
  1655.     HEX    c800.0000.c800.01ce
  1656.     HEX    c800.0339.c800.0332
  1657.     HEX    c800.0324.c800.0308
  1658.     HEX    c800.0304.cfff.e322
  1659.     HEX    c000.1331.c000.1339
  1660.     HEX    ffff.e3cf.7fff.c1c6
  1661. *
  1662.     HEX    71c7.fffe.fbef.ffff
  1663.     HEX    ffef.ffff.7fff.ffff
  1664.     HEX    3fff.ffff.1fff.ffff
  1665.     HEX    1fff.ffff.1fff.ffff
  1666.     HEX    1fff.ffff.1fff.ffff
  1667.     HEX    0fff.ffff.3fff.ffff
  1668.     HEX    7fff.ffff.ffff.ffff
  1669.     HEX    ffff.ffff.ffff.ffff
  1670.     HEX    ffff.ffff.ffff.ffff
  1671.     HEX    ffff.ffff.ffff.ffff
  1672.     HEX    ffff.fffe.ffff.ffff
  1673.     HEX    ffff.ffff.ffff.ffff
  1674.     HEX    ffff.fffe.ffff.fffc
  1675.     HEX    ffff.fffc.ffff.fffe
  1676.     HEX    ffff.ffff.ffff.f3ff
  1677.     HEX    ffff.e3ef.7fff.c1c6
  1678.     ENDR
  1679. *
  1680.     RSRC    ICN#,131,32
  1681.     HEX    71c7.fffe.cb2c.0001
  1682.     HEX    c62c.0001.604f.fff9
  1683.     HEX    3087.fff9.1900.0019
  1684.     HEX    1900.0019.1900.0019
  1685.     HEX    1909.1899.1e09.2499
  1686.     HEX    0c09.2499.0009.1899
  1687.     HEX    7000.0019.c800.0019
  1688.     HEX    c989.2319.ca49.2499
  1689.     HEX    ca49.2499.c989.2319
  1690.     HEX    c800.001f.c800.000f
  1691.     HEX    c988.c000.ca49.21ce
  1692.     HEX    ca49.2339.c988.c332
  1693.     HEX    c800.0324.c800.0308
  1694.     HEX    c800.0304.cfff.f322
  1695.     HEX    c000.0b31.c000.0b39
  1696.     HEX    ffff.f3cf.7fff.e1c6
  1697. *
  1698.     HEX    71c7.fffe.fbef.ffff
  1699.     HEX    ffef.ffff.7fff.ffff
  1700.     HEX    3fff.ffff.1fff.ffff
  1701.     HEX    1fff.ffff.1fff.ffff
  1702.     HEX    1fff.ffff.1fff.ffff
  1703.     HEX    0fff.ffff.0fff.ffff
  1704.     HEX    7fff.ffff.ffff.ffff
  1705.     HEX    ffff.ffff.ffff.ffff
  1706.     HEX    ffff.ffff.ffff.ffff
  1707.     HEX    ffff.ffff.ffff.ffff
  1708.     HEX    ffff.fffe.ffff.ffff
  1709.     HEX    ffff.ffff.ffff.ffff
  1710.     HEX    ffff.fffe.ffff.fffc
  1711.     HEX    ffff.fffc.ffff.fffe
  1712.     HEX    ffff.ffff.ffff.ffff
  1713.     HEX    ffff.f7ff.7fff.e7ce
  1714.     ENDR
  1715. *
  1716.     RSRC    ICN#,132,32
  1717.     HEX    71